;;;; © 2016-2020 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.utilities)

(defconstant +bitfield-max-bits+
  (1- (integer-length most-positive-fixnum)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Bitfield Slots

(defgeneric bitfield-slot-name (bitfield-slot))

(defgeneric bitfield-slot-start (bitfield-slot))

(defgeneric bitfield-slot-end (bitfield-slot))

(defgeneric bitfield-slot-size (bitfield-slot))

(defgeneric bitfield-slot-reader (bitfield-slot))

(defgeneric bitfield-slot-initform (bitfield-slot))

(defgeneric bitfield-slot-pack (bitfield-slot value-form))

(defgeneric bitfield-slot-unpack (bitfield-slot value-form))

;;; The Base Class

(defclass bitfield-slot ()
  ((%name :initarg :name :reader bitfield-slot-name)
   (%reader :initarg :reader :reader bitfield-slot-reader)
   (%start :initarg :start :reader bitfield-slot-start)
   (%end :initarg :end :reader bitfield-slot-end)))

(defmethod bitfield-slot-size ((slot bitfield-slot))
  (- (bitfield-slot-end slot)
     (bitfield-slot-start slot)))

(defmethod bitfield-slot-initform ((slot bitfield-slot))
  0)

(defmethod bitfield-slot-pack ((slot bitfield-slot) value-form)
  value-form)

(defmethod bitfield-slot-unpack ((slot bitfield-slot) value-form)
  value-form)

;;; Boolean Slots

(defclass bitfield-boolean-slot (bitfield-slot)
  ())

(defmethod bitfield-slot-initform ((slot bitfield-boolean-slot))
  nil)

(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form)
  `(if ,value-form 1 0))

(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form)
  `(ecase ,value-form (0 nil) (1 t)))

;;; (Un)signed Byte Slots

(defclass bitfield-unsigned-byte-slot (bitfield-slot)
  ())

(defclass bitfield-signed-byte-slot (bitfield-slot)
  ())

(defmethod bitfield-slot-pack ((slot bitfield-signed-byte-slot) value-form)
  `(the (unsigned-byte ,(bitfield-slot-size slot))
        (+ ,value-form ,(expt 2 (1- (bitfield-slot-size slot))))))

(defmethod bitfield-slot-unpack ((slot bitfield-signed-byte-slot) value-form)
  `(- (the (unsigned-byte ,(bitfield-slot-size slot))
           ,value-form)
      ,(expt 2 (1- (bitfield-slot-size slot)))))

;;; Parsing

(defvar *bitfield-name*)

(defvar *bitfield-position*)

(defun parse-bitfield-slot (slot)
  (destructuring-bind (slot-name type) slot
    (let* ((prefix (symbol-name *bitfield-name*))
           (suffix (symbol-name slot-name))
           (reader (intern (concatenate 'string prefix "-" suffix)
                           (symbol-package *bitfield-name*))))
      (trivia:match type
        ('boolean
         (make-instance 'bitfield-boolean-slot
           :name slot-name
           :reader reader
           :start *bitfield-position*
           :end (incf *bitfield-position*)))
        ((list 'unsigned-byte n)
         (make-instance 'bitfield-unsigned-byte-slot
           :name slot-name
           :reader reader
           :start *bitfield-position*
           :end (incf *bitfield-position* n)))
        ((list 'signed-byte n)
         (make-instance 'bitfield-signed-byte-slot
           :name slot-name
           :reader reader
           :start *bitfield-position*
           :end (incf *bitfield-position* n)))))))

(defmacro define-bitfield (name &body slots)
  "Defines an efficient collection of booleans and small integers.

For a supplied bitfield name NAME, and for some slot definitions of the
form (SLOT-NAME TYPE), this macro defines the following functions:

1. A constructor named MAKE-{NAME}, that takes one keyword argument per
   SLOT-NAME, similar to the default constructor generated by DEFSTRUCT.
   It returns a bitfield whose entries have the values indicated by the
   keyword arguments, or a reasonable default (NIL for booleans, 0 for
   numbers).

2. A clone operation named CLONE-{NAME}, that takes an existing bitfield
   and one keyword argument per SLOT-NAME.  It returns a copy of the
   existing bitfield, but where each supplied keyword argument supersedes
   the value of the corresponding slot.

3. A reader function named {NAME}-{SLOT-NAME} for each slot.

In addition to these functions, NAME is defined as a suitable subtype
of (and unsigned-byte fixnum).

Currently this macro supports boolean, unsigned-byte and signed-byte slots.

 Example:

 (define-bitfield examplebits
   (a boolean)
   (b boolean)
   (c boolean)
   (x (signed-byte 5))
   (id (unsigned-byte 16)))

 (defparameter *a*
   (make-examplebits :a nil :b t :id 42))

 (list
  (examplebits-a *a*)
  (examplebits-b *a*)
  (examplebits-c *a*)
  (examplebits-x *a*)
  (examplebits-id *a*))

 ;; Returns (NIL T NIL 0 42)

 (defparameter *b*
   (clone-examplebits *a* :c t :x -2))

 (list
  (examplebits-a *b*)
  (examplebits-b *b*)
  (examplebits-c *b*)
  (examplebits-x *b*)
  (examplebits-id *b*))

 ;; Returns (NIL T T -2 42)
"
  (let* ((*bitfield-name* name)
         (*bitfield-position* 0)
         (slots
           (mapcar #'parse-bitfield-slot slots))
         (constructor
           (intern (concatenate 'string "MAKE-" (symbol-name name))
                   (symbol-package name)))
         (cloner
           (intern (concatenate 'string "CLONE-" (symbol-name name))
                   (symbol-package name))))
    (assert (<= *bitfield-position* +bitfield-max-bits+))
    `(progn
       (deftype ,name () '(unsigned-byte ,*bitfield-position*))
       ;; Define all slot readers.
       ,@(loop for slot in slots
               collect
               `(declaim (inline ,(bitfield-slot-reader slot)))
               collect
               `(defun ,(bitfield-slot-reader slot) (,name)
                  (declare (,name ,name))
                  ,(bitfield-slot-unpack
                    slot
                    `(ldb (byte ,(bitfield-slot-size slot)
                                ,(bitfield-slot-start slot))
                          ,name))))
       ;; Define the cloner.
       (declaim (inline ,cloner))
       (defun ,cloner
           (,name &key ,@(loop for slot in slots
                               collect
                               `(,(bitfield-slot-name slot)
                                 (,(bitfield-slot-reader slot) ,name))))
         (declare (,name ,name))
         (logior
          ,@(loop for slot in slots
                  collect
                  `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
                        ,(bitfield-slot-start slot)))))
       ;; Define the constructor.
       (declaim (inline ,constructor))
       (defun ,constructor
           (&key ,@(loop for slot in slots
                         collect
                         `(,(bitfield-slot-name slot)
                           ,(bitfield-slot-initform slot))))
         (logior
          ,@(loop for slot in slots
                  collect
                  `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
                        ,(bitfield-slot-start slot))))))))

